{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  ContML.Syntax
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Syntax of source language.
--
-- Note - Concrete syntax for @try@ changed from the paper.
--
--------------------------------------------------------------------------------


module ContML.Syntax 
  ( 

    Expr(..)
  , Def(..)
  , Sum(..)

  , ppExpr

  ) where


import ContML.VarId

import Text.PrettyExprHPJ.MosML                 -- package: pretty-expr-hpj

import Text.PrettyPrint.HughesPJ                -- package: pretty

data Expr = Unit
          | Var VarId
          | Int Int
          | App Expr Expr
          | Fun VarId Expr
          | Pair Expr Expr
          | Unpair Int Expr
          | Tag Int Expr
          | LetVal VarId Expr Expr
          | Case Expr VarId Expr VarId Expr
          | Raise Expr
          | Handle Expr VarId Expr
          | LetFun [Def] Expr
  deriving (Eq,Show)
  

data Def = Def VarId VarId Expr
  deriving (Eq,Show)

data Sum a b = In1 a | In2 b
  deriving (Eq,Show)



ppExpr :: Expr -> Doc
ppExpr = unparse . exprDoc

exprDoc :: Expr -> DocE
exprDoc (Unit)                      = literal "()"
exprDoc (Var vid)                   = literal $ var_name vid
exprDoc (Int i)                     = Atom $ int i
exprDoc (App e1 e2)                 = funAppB1 (exprDoc e1) (exprDoc e2)
exprDoc (Fun vid e)                 = 
    Atom $ text "fn" <+> text (var_name vid) <+> text "=>" <+> ppExpr e

exprDoc (Pair e1 e2)                = 
    Atom $ parens (ppExpr e1 <> comma <> ppExpr e2)

exprDoc (Unpair i e)                = 
    Atom $ char '#' <> int i <+> ppExpr e

exprDoc (Tag i e)                   = 
    Atom $ text "in" <> int i <+> ppExpr e

exprDoc (LetVal vid e1 e2)          = 
    Atom $ text "let val" <+> text (var_name vid) 
                          <+> char '='   <+> ppExpr e1
                          $+$ text "in"  <+> nest 2 (ppExpr e2)
                          $+$ text "end"

exprDoc (Case e0 v1 e1 v2 e2)       = 
    Atom $ text "case" <+> ppExpr e0 <+> text "of" 
                       $+$ text "  " <+> text "in1" <+> text (var_name v1)
                                     <+> text "=>"  <+> ppExpr e1
                       $+$ text "| " <+> text "in2" <+> text (var_name v2)
                                     <+> text "=>"  <+> ppExpr e2

exprDoc (Raise e)                   = Atom $ text "raise" <+> ppExpr e
exprDoc (Handle e1 v e2)            = 
    Atom $ text "try" <+> ppExpr e1 
                      <+> text "handle" <+> text (var_name v) 
                      <+> text "=>" <+> ppExpr e2

exprDoc (LetFun ds e)               =
    Atom $ text "let fun" <+> vcat (map ppDef ds)
                          $+$ text "in" <+> nest 2 (ppExpr e)
                          $+$ text "end"


ppDef :: Def -> Doc
ppDef (Def f x e)                   = 
    text (var_name f) <+> text (var_name x) <+> char '=' <+> ppExpr e